home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Utilities / Miscellaneous / CopyPaste 3.3.4 / CopyPaste Tools Sourcecode / Bahai Date / Bahá'í-Date.p < prev    next >
Encoding:
Text File  |  1997-06-06  |  7.0 KB  |  274 lines  |  [TEXT/CWIE]
  1. {•This sourcecode is an example for creating a FKey coderesource with•}
  2. {•Metrowerks Pascal. It is copyrighted by Peter Hoerster and released•}
  3. {•for free use in any Shareware or Freeware product as a way to thank all•}
  4. {•programmers who share code snippets. You may put this sources on any•}
  5. {•CD ROM or any Archive Server but you may not sell it. •}
  6.  
  7. {• For comments please write to <hoerster@muenster.de>•}
  8.  
  9.  
  10. unit BahaiDate;
  11.  
  12. interface
  13.     uses
  14.         Types, OSUtils, GestaltEqu, Script, notification, Resources, Events,
  15.          PascalA4, QuickDraw, ToolUtils, Memory, LowMem, Scrap, script;
  16.  
  17.  
  18.  
  19. {$MAIN}
  20.                         
  21.     procedure main;    
  22.         
  23.  
  24. implementation
  25.  
  26.     procedure dopaste;
  27.     const
  28.         pastecode=2422;
  29.     var 
  30.         qel: EvQelPtr;
  31.     begin
  32.             if ppostevent(3, pastecode, qel) = noerr then
  33.             qel^.evtqmodifiers := cmdkey;
  34.     end;
  35.  
  36.  
  37.     procedure main;
  38.         var
  39.         
  40.             var
  41.             oldA4: LongInt;
  42.             BahaiMonth: array[1..20] of str31;
  43.             NumberOfDaysInMonth: array[1..12] of integer;
  44.             Day, Month, Year: longint;
  45.             Result: str255;
  46.             alongint: longint;
  47.             myerr: oserr;
  48.         procedure InitGerman;
  49.         begin
  50.             BahaiMonth[1] := 'Sharaf - Ehre';
  51.             BahaiMonth[2] := 'Sultán - Herrschaft';
  52.             BahaiMonth[3] := 'Mulk - Hoheit';
  53.             BahaiMonth[4] := 'Ayyam-i-Há';
  54.             BahaiMonth[5] := 'Alá - Erhabenheit';
  55.             BahaiMonth[6] := 'Bahá - Glanz';
  56.             BahaiMonth[7] := 'Jalal - Ruhm';
  57.             BahaiMonth[8] := 'Jamal - Schönheit';
  58.             BahaiMonth[9] := '`Azamat - Größe';
  59.             BahaiMonth[10] := 'Nur - Licht';
  60.             BahaiMonth[11] := 'Rahmat - Erbarmen';
  61.             BahaiMonth[12] := 'Kalimat - Worte';
  62.             BahaiMonth[13] := 'Kamál - Vollkommenheit';
  63.             BahaiMonth[14] := 'Asmá´ - Namen';
  64.             BahaiMonth[15] := '`Izzat - Würde';
  65.             BahaiMonth[16] := 'Mashíat - Wille';
  66.             BahaiMonth[17] := '`Ilm - Wissen';
  67.             BahaiMonth[18] := 'Qudrat - Macht';
  68.             BahaiMonth[19] := 'Qawl - Sprache';
  69.             BahaiMonth[20] := 'Masá`il - Fragen';
  70.         end;
  71.         procedure InitEnglish;
  72.         begin
  73.             BahaiMonth[1] := 'Sharaf - Honor';
  74.             BahaiMonth[2] := 'Sultán - Souvereignty';
  75.             BahaiMonth[3] := 'Mulk - Dominion';
  76.             BahaiMonth[4] := 'Ayyam-i-Há - Intercalery day';
  77.             BahaiMonth[5] := 'Alá - Loftiness';
  78.             BahaiMonth[6] := 'Bahá - Splendor';
  79.             BahaiMonth[7] := 'Jalal - Glory';
  80.             BahaiMonth[8] := 'Jamal - Beauty';
  81.             BahaiMonth[9] := '`Azamat - Grandeur';
  82.             BahaiMonth[10] := 'Nur - Light';
  83.             BahaiMonth[11] := 'Rahmat - Mercy';
  84.             BahaiMonth[12] := 'Kalimat - Words';
  85.             BahaiMonth[13] := 'Kamál - Perfection';
  86.             BahaiMonth[14] := 'Asmá´ - Names';
  87.             BahaiMonth[15] := '`Izzat - Might';
  88.             BahaiMonth[16] := 'Mashíat - Will';
  89.             BahaiMonth[17] := '`Ilm - Knowledge';
  90.             BahaiMonth[18] := 'Qudrat - Power';
  91.             BahaiMonth[19] := 'Qawl - Speech';
  92.             BahaiMonth[20] := 'Masá`il - Questions';
  93.         end;
  94.  
  95.  
  96.         procedure InitJapan;
  97.         begin
  98.             BahaiMonth[1] := 'Sharaf - ñºó_';
  99.             BahaiMonth[2] := 'Sultán - ìùé°å†';
  100.             BahaiMonth[3] := 'Mulk - éÂå†';
  101.             BahaiMonth[4] := 'Ayyam-i-Há';
  102.             BahaiMonth[5] := 'Alá - çÇèÆ';
  103.             BahaiMonth[6] := 'Bahá - âÿóÌ';
  104.             BahaiMonth[7] := 'Jalal - é^î¸';
  105.             BahaiMonth[8] := 'Jamal - î¸';
  106.             BahaiMonth[9] := '`Azamat - ësëÂÇ≥';
  107.             BahaiMonth[10] := 'Nur - åı';
  108.             BahaiMonth[11] := 'Rahmat - éúîfl';
  109.             BahaiMonth[12] := 'Kalimat - åæót';
  110.             BahaiMonth[13] := 'Kamál - è[é¿';
  111.             BahaiMonth[14] := 'Asmá´ - ñºëO';
  112.             BahaiMonth[15] := '`Izzat - àÃóÕ';
  113.             BahaiMonth[16] := 'Mashíat - à”éu';
  114.             BahaiMonth[17] := '`Ilm - íméØ';
  115.             BahaiMonth[18] := 'Qudrat - óÕ';
  116.             BahaiMonth[19] := 'Qawl - åæìÆ';
  117.             BahaiMonth[20] := 'Masá`il - ñ‚ìö';
  118.         end;
  119.  
  120.  
  121.         procedure initmonths;
  122.             var
  123.                 i:integer;
  124.                 result: longint;
  125.         begin
  126.             result := getscriptVariable(-1, smscriptlang);
  127.             if result = 2 then
  128.                 InitGerman
  129.             else if result = 11 then
  130.                 InitJapan
  131.             else
  132.                 InitEnglish;
  133.             for i:=1 to 12 do 
  134.                 NumberOfDaysInMonth[i] := 31;
  135.             NumberOfDaysInMonth[4] := 30;
  136.             NumberOfDaysInMonth[6] := 30;
  137.             NumberOfDaysInMonth[9] := 30;
  138.             NumberOfDaysInMonth[11] := 30;
  139.         end;
  140.  
  141.  
  142.  
  143.  
  144.         function convertit: str255;
  145.             var
  146.  
  147.                 f: longint;
  148.                 e: Integer;
  149.                 
  150.  
  151.             function AddDayInLeapYear: integer;
  152.             begin
  153.                 if Year mod 4 = 0 then {LeapYear?}
  154.                     begin
  155.                         NumberOfDaysInMonth[2] := 29;
  156.                         AddDayInLeapYear := 5;
  157.                         
  158.                     end
  159.                 else
  160.                     begin
  161.                         NumberOfDaysInMonth[2] := 28;
  162.                         AddDayInLeapYear := 4;
  163.                         
  164.                     end
  165.             end;
  166.  
  167.             function DayInYear:integer;
  168.                 var
  169.                     c,i: integer;
  170.             begin
  171.                 c := 0;      
  172.                 for i := 1 to Month do
  173.                     c := c + NumberOfDaysInMonth[i];
  174.                 DayInYear := c - NumberOfDaysInMonth[Month] + Day;{Berechnung der Tagesordnungs-Zahl c  im Jahr}
  175.             end;
  176.  
  177.             
  178.  
  179.             procedure DoDayMonthYear(LeapDays:integer;TheDay:integer);
  180.             begin
  181.                 if TheDay < 57 then{Block vor den Eingeschobenen Tagen}
  182.                     begin
  183.                         e := (TheDay div 19) + 1; {e ist BIMonats-Zahl}
  184.                         f := 1 + round((TheDay + 19) - e * 19); {f ist Tagesordnungs-Zahl im BIMonat}
  185.                     end
  186.                 else if TheDay < 57 + LeapDays then {eingeschobene Tage}
  187.                     begin
  188.                         e := 4;{e ist BIMonats-Zahl}
  189.                         f := TheDay - 56;{f ist Tagesordnungs-Zahl im BIMonat}
  190.                     end
  191.                 else if TheDay > 56 + LeapDays then {Block nach den eingeschobenen Tagen}
  192.                     begin
  193.                         e := 2 + ((TheDay - LeapDays) div 19); {e ist BIMonats-Zahl}
  194.                         f := 1 + round((TheDay - LeapDays + 38) - e * 19); {f ist Tagesordnungs-Zahl im BIMonat}
  195.                     end;
  196.                 Year := Year - 1844;
  197.                 if TheDay > 75 + LeapDays then
  198.                     Year := succ(Year); {Jahr ist jetzt das Bahá'i Jahr}
  199.             end;
  200.  
  201.             function ResultString: str255;
  202.                 var
  203.                     badi: string[32];
  204.                     thestr, stri: str255;
  205.             begin
  206.                 if e > 20 then
  207.                     e := 1;
  208.                 badi := BahaiMonth[e];
  209.                 numtostring(f, stri);
  210.                 numtostring(Year, thestr);
  211.                 ResultString := concat(stri, '. ', badi, ' ', thestr);
  212.  
  213.             end;
  214.  
  215.         begin
  216.             DoDayMonthYear(AddDayInLeapYear,DayInYear);
  217.             convertit := ResultString;
  218.         end;
  219.  
  220.  
  221.     
  222.  
  223.         function scraphandling: boolean;
  224.             var
  225.                 
  226.                 newsize, mysize: size;
  227.                 cliphandle: handle;
  228.                 datecache: DateCacheRecord;
  229.                 thedate: datetimerec;
  230.                 lenghtused: longint;
  231.                 datetime: longdaterec;
  232.                 dateresult: String2DateStatus;
  233.         begin
  234.             scraphandling := false;
  235.             if InitDateCache(@datecache) = noerr then
  236.                 begin
  237.                     clipHandle := NewHandle(0);
  238.                     mysize := GetScraP(clipHandle, 'TEXT', newsize);
  239.                     dateresult := StringToDate (cliphandle^, gethandlesize(cliphandle), @datecache, lenghtused, datetime);
  240.                     case dateresult of
  241.                         noerr, longDateFound, leftoverchars, sepnotintlsep, fieldordernotintl, extraneousstrings, toomanyseps, sepnotconsistent: 
  242.                             begin
  243. {22.2.1922}
  244.                                 Day := datetime.day;
  245.                                 Month := datetime.month;
  246.                                 Year := datetime.year;
  247.                                 scraphandling := true;
  248.                             end;
  249.                         otherwise
  250.                             begin
  251.                                 GetDateTime(aLongInt);
  252.                                 SecondsToDate (alongint, thedate);
  253.                                 Day := thedate.day;
  254.                                 Month := thedate.month;
  255.                                 Year := thedate.year;
  256.                                 scraphandling := true;
  257.                             end;
  258.                     end;
  259.                 end;
  260.         end;
  261.     begin
  262.         oldA4 := SetCurrentA4;
  263.         initmonths;
  264.         if scraphandling = true then
  265.             begin
  266.                 Result := convertit;
  267.                 myerr := Zeroscrap;
  268.                 alongint := length(Result);
  269.                 myErr := PutScrap(alongint, 'TEXT', @Result[1]);
  270.                 dopaste;
  271.             end;
  272.         oldA4 := SetA4(oldA4);
  273.     end;
  274. end.